home *** CD-ROM | disk | FTP | other *** search
/ Atari Forever 4 / Atari Forever 4.zip / Atari Forever 4.iso / PD_THEMA / BIORHYTM / BIORYTHM / BIORHYTH.LST < prev   
File List  |  1998-03-14  |  10KB  |  432 lines
  1. ' ***********************************************************************
  2. ' *  Biorhythmus ST                Version GfA-BASIC                    *
  3. ' *  15.02.87                                                           *
  4. ' *                                WOLFGANG WENK                        *
  5. ' *  >>> KOPIEREN ERLAUBT <<<      Hauptstr.22, 2167 Himmelpforten      *
  6. ' *                                Tel.: 04144/8678                     *
  7. ' *  INPUTFORM  -    Routine von   MICHAEL VAGTS, Stade                 *
  8. ' ***********************************************************************
  9. If Xbios(4)<>2 Then
  10.   Alert 3,"Der BIORHYTHMUS   läuft|nur in der|hohen Auflösung",1,"schade",Dummy%
  11.   End
  12. Endif
  13. '
  14. Dim Modus$(10)
  15. Dim Korx(500),Kory(500),Seey(500),Geiy(500)
  16. '
  17. Alert 1,"Programm  BIORHYTHMUS|   (c) W.Wenk 1987|  | >>> PUBLIC DOMAIN <<< ",1,"Auja|Needanke",A%
  18. If A%=1
  19.   Deftext ,16,,32
  20.   Text 100,100,"Dann geht's jetzt los!!"
  21.   Pause 50
  22. Endif
  23. If A%=2
  24.   Goto Schluss
  25. Endif
  26. Pause 50
  27. ' ----------------> INIT
  28. ' ***************** Mouse als Fragezeichen
  29. Let Bio$=Mki$(2)+Mki$(1)+Mki$(1)
  30. Let Bio$=Bio$+Mki$(0)+Mki$(1)
  31. For I%=1 To 16
  32.   Read Hinten
  33.   Let Bio$=Bio$+Mki$(Hinten)
  34. Next I%
  35. For I%=1 To 16
  36.   Read Vorn
  37.   Let Bio$=Bio$+Mki$(Vorn)
  38. Next I%
  39. Data 1792,6272,8256,17952,18832,18576,31008,576,3200,2304,2304,2304,3840,2304,2304,3840
  40. Data 0,1792,8064,14784,12384,12384,192,384,768,1536,1536,1536,0,1536,1536,0
  41. Defmouse Bio$
  42. '
  43. Sauber$=Chr$(27)+"E"
  44. '
  45. Logo$=Chr$(14)+Chr$(15)+" B I O R H Y T H M U S "+Chr$(14)+Chr$(15)
  46. '
  47. Dim Monattage%(13)
  48. Dim Tagesname$(7)
  49. For I%=1 To 13
  50.   Read Monattage%(I%)
  51. Next I%
  52. For I%=1 To 7
  53.   Read Tagesname$(I%)
  54. Next I%
  55. '
  56. Data 0,31,59,90,120,151,181,212,243,273,304,334,365
  57. Data Sonntag,Montag,Dienstag,Mittwoch,Donnerstag,Freitag,Samstag
  58. '
  59. ' -------------> Titel
  60. Titel:
  61. '
  62. Print Sauber$
  63. '
  64. Deftext 1,0,0,6
  65. For I%=10 To 270
  66.   Text I%,320," W.Wenk 1987"
  67. Next I%
  68. Text 260,320,Chr$(189)
  69. Deftext ,0,0,9
  70. Text 160,20,Logo$
  71. Deffill 1,2,1
  72. Line 0,22,639,22
  73. Prbox 550,300,80,50
  74. '
  75. Graphmode 1
  76. Rbox 555,305,85,55
  77. Defline 1,4,0,0
  78. Line 110,70,110,280
  79. Defline 1,4,0,1
  80. Line 110,180,540,180
  81. Defline 1,1,0,0
  82. Text 90,90,"+"
  83. Text 90,185,"0"
  84. Text 90,270,"-"
  85. '
  86. For I=120 To 540 Step 0.5
  87.   S=Sin(I*Pi/80)*80+160
  88.   Line I-5,S-5,I+5,S+5
  89. Next I
  90. For K=120 To 540 Step 0.5
  91.   S=Sin(K*Pi/60)*60+160
  92.   Line K-1,S-1,K+1,S+1
  93. Next K
  94. Deftext ,1,0,8
  95. Box 150,370,300,350
  96. Deffill ,2,3
  97. Pbox 269,370,301,350
  98. Text 155,365,"Erklärung "
  99. Defline 1,4,0,0
  100. Box 320,370,470,350
  101. Defline 1,1,0,0
  102. Pbox 440,368,468,352
  103. Text 325,365,"Los geht's"
  104. '
  105. Defline 1,2,0,0
  106. Repeat
  107. Until Len(Inkey$) Or Mousek
  108. If Mousex>269 And Mousex<300 And Mousey>350 And Mousey<370
  109.   Goto Erklaerung
  110. Endif
  111. Goto Eingabe
  112. '
  113. '
  114. Erklaerung:
  115. '
  116. Print Sauber$
  117. Deftext ,0,0,9
  118. Text 160,20,Logo$
  119. Rbox 620,380,25,25
  120. Deftext ,16,0,9
  121. Text 150,60,"Was ist der BIORYTHMUS ??"
  122. Text 150,75,"-------------------------"
  123. Deftext ,1,0,6
  124. Text 40,100,"BIORHYTHMUS hat nichts mit Tanzen zu tun,wie Du vielleicht denkst."
  125. Text 40,110,"Schon die alten Griechen glaubten, daß das Leben in bestimmten "
  126. Text 40,120,"Zyklen abläuft. Die Zyklen beginnen bei der Geburt als Sinuskurve"
  127. Text 40,130,"zu laufen."
  128. Deftext ,1,0,8
  129. Text 70,160,"1. Der PHYSISCHE     Zyklus = 23 Tage "
  130. Text 70,175,"2. Der EMOTIONALE    Zyklus = 28 Tage "
  131. Text 70,190,"3. Der INTELEKTUELLE Zyklus = 33 Tage "
  132. Deftext ,1,0,6
  133. Text 40,210,"Kritisch sind immer nur die Tage, an denen sich die Kurve mit der "
  134. Text 40,220,"Mittelachse kreuzt. Vielen Leute glauben, daß man an diesen Tagen"
  135. Text 40,230,"häufiger Fehler macht, Unfälle passieren oder man körperlich"
  136. Text 40,240,"anfälliger ist. Sollte sich für Dich ergeben, daß heute ein"
  137. Text 40,250,"kritischer Tag ist, und Du machst keinen Fehler, Dir fällt kein"
  138. Text 40,260,"Ziegelstein auf den Kopf oder Du hast keinen Nervenzusammenbruch,"
  139. Text 40,270,"mach' mich bitte nicht dafür verantwortlich!!"
  140. Deftext ,5,0,13
  141. Text 160,300,"Und nun viel Spaß mit den Kurven !! "
  142. Box 240,380,410,350
  143. Deftext ,16,0,16
  144. Text 250,370,"Alles klar ??"
  145. Deftext ,1,0,5
  146. Repeat
  147.   Text 250,381,"-->  T A S T E   <--"
  148.   Pause 10
  149.   Text 250,381,"                    "
  150. Until Len(Inkey$) Or Mousek
  151. Goto Eingabe
  152. '
  153. '
  154. Eingabe:
  155. Print Sauber$
  156. Graphmode 1
  157. Deftext ,0,0,9
  158. Text 160,20,Logo$
  159. Deffill 1,2,2
  160. Line 0,22,639,22
  161. Prbox 40,45,560,80
  162. Deffill ,,1
  163. Prbox 40,81,560,350
  164. Deftext ,16,0,13
  165. Text 50,68,"Meine Fragen"
  166. Text 390,68,"Deine Antworten"
  167. Deftext ,0,0,13
  168. Text 45,100,"Dein Name: "
  169. X=420
  170. Y=100
  171. Modus=3
  172. Laenge=10
  173. Gosub Inputform
  174. Nam$=Key$
  175. '
  176. '
  177. Text 45,120,"..und Dein Geburtsdatum "+Upper$(Nam$)
  178. Text 45,138,"[z.B. 1.Aug.1960 = 01081960]"
  179. Eindat1:
  180. Y=138
  181. Modus=1
  182. Laenge=8
  183. Gosub Inputform
  184. Gebdat$=Key$
  185. '
  186. If (Val(Mid$(Gebdat$,3,2))>12) Or (Val(Left$(Gebdat$,2))>31)
  187.   Goto Fehler1
  188.   If (Val(Mid$(Gebdat$,3,2))<=0) Or (Val(Left$(Gebdat$,2))<=0)
  189.     Goto Fehler1
  190.   Endif
  191. Endif
  192. ' -----------------> wochentag der geburt
  193. '
  194. Gebtag=Val(Left$(Gebdat$,2))
  195. Gebmon=Val(Mid$(Gebdat$,3,2))
  196. Gebjah=Val(Right$(Gebdat$,4))
  197. Gebmon=Int(Gebmon)
  198. Gebtag=Int(Gebtag)
  199. Gebjah=Int(Gebjah)
  200. Tageab=Int(Gebtag+365.25*Gebjah+Monattage%(Gebmon)+0.01*Gebmon-0.03)
  201. K=Int(0.6+(1/Gebmon))
  202. L=Gebjah-K
  203. O=Gebmon+12*K
  204. P=L/100
  205. Z1=Int(P/4)
  206. Z2=Int(P)
  207. Z3=Int((5*L)/4)
  208. Z4=Int(13*(O+1)/5)
  209. Z=Z4+Z3-Z2+Z1+Gebtag-1
  210. Z=(Z-(7*Int(Z/7)))+1
  211. '
  212. Text 45,180,"Für welchen Monat soll ich die Kurven berechnen ?"
  213. Text 45,200,"[z.B. MAI 1986 = 051986]"
  214. Eindat2:
  215. Y=200
  216. Laenge=6
  217. Gosub Inputform
  218. Start$="01"+Key$
  219. If Val(Mid$(Start$,3,2))>12
  220.   Goto Fehler2
  221. Endif
  222. If Val(Right$(Start$,4))<=Gebjah
  223.   Goto Fehler3
  224. Endif
  225. '
  226. ' -------------------------> gesamttage berechnen
  227. '
  228. Bistag=Val(Left$(Start$,2))
  229. Bismon=Val(Mid$(Start$,3,2))
  230. Bisjah=Val(Right$(Start$,4))
  231. Nochmal:
  232. Bismon=Int(Bismon)
  233. Bistag=Int(Bistag)
  234. Bisjah=Int(Bisjah)
  235. Tagebis=Int(Bistag+365.25*Bisjah+Monattage%(Bismon)+0.01*Bismon-0.03)
  236. Altertage=Tagebis-Tageab+1
  237. Deffill 0,2,1
  238. Defline 1,1,0,0
  239. Prbox 55,230,540,340
  240. For I=10 To 30 Step 5
  241.   Rbox 60+I,235+I,540-I,340-I
  242. Next I
  243. Graphmode 1
  244. Deftext ,17,8
  245. Text 150,235,"Das erste Zwischenergebnis !"
  246. Deftext ,1,5
  247. Text 110,285,400,"Du bist  in diesem Monat "+Str$(Altertage)+" Tage alt "
  248. Text 120,301,320,"  und an einem   "+Tagesname$(Z)+"  geboren !"
  249. For I%=11 To 31 Step 1
  250.   Rbox 60+I%,235+I%,540-I%,340-I%
  251. Next I%
  252. Deftext ,16,,6
  253. Repeat
  254.   Text 230,322,"--> Taste <--"
  255.   Pause 10
  256.   Text 230,322,"             "
  257. Until Len(Inkey$) Or Mousek
  258. '
  259. ' --------------------> Berechnen Kurvenfaktor
  260. '
  261. Ps=(Altertage) Mod (23)              ! Koerper
  262. Es=(Altertage) Mod (28)              ! Emotion
  263. Is=(Altertage) Mod (33)              ! Intellekt
  264. '
  265. ' -------------------> Bildschirm für Kurven
  266. Print Sauber$
  267. Deftext ,0,0,9
  268. Text 160,20,Logo$
  269. Defline 1,1,0,0
  270. Line 0,22,639,22
  271. Line 568,48,568,310
  272. Line 72,310,72,48
  273. Line 72,190,568,190
  274. Deffill 1,2,2
  275. Pbox 72,48,568,91
  276. Deffill 0,2,8
  277. Pbox 78,55,560,82
  278. Box 78,55,560,82
  279. Box 72,289,568,310
  280. Deftext 1,1,0,13
  281. Text 75,305,"1  3   5   7   9  11  13  15  17  19  21  23  25  27  29  31"
  282. Text 80,75,"Für "+Upper$(Nam$)
  283. Text 430,75,"* "+Left$(Gebdat$,2)+"."+Mid$(Gebdat$,3,2)+"."+Right$(Gebdat$,4)
  284. Deftext 1,17,0,16
  285. Text 280,75,Str$(Bismon)+"/"+Str$(Bisjah)
  286. Deftext ,,,26
  287. Text 600,170,"+"
  288. Text 600,270,"-"
  289. Defline 1,2,3,3
  290. Line 73,343,110,343
  291. Defline 3,2,3,3
  292. Line 73,357,110,357
  293. Defline 6,2,3,3
  294. Line 73,372,110,372
  295. Deftext 1,1,0,6
  296. Text 72,330,"Es bedeutet:"
  297. Text 115,345,"= physisch/Körper"
  298. Text 115,360,"= Emotion/Gefühl"
  299. Text 115,375,"= Intellekt/Geist"
  300. Text 355,330,"[RETURN] = neuer Monat"
  301. Text 355,345,"[SPACE]  = neue  Daten"
  302. Text 355,360,"   *     = FEIERABEND !!"
  303. Text 355,375,"[ALTERN+HELP]= Ausdruck"
  304. ' ----------------------------> Kurven zeichnen
  305. '
  306. Deftext 1,1,0,13
  307. Defline 1,2,0,0
  308. For X=88 To 552 Step 16
  309.   Line X,91,X,289
  310. Next X
  311. '
  312. For K=0 To 496 Step 8
  313.   Korx(K)=K+72
  314.   Kory(K)=190-50*Sin(Pi*2/496*K*31/23-Pi/23+Pi*2*Ps/23)
  315.   Seey(K)=190-50*Sin(Pi*2/496*K*31/28-Pi/28+Pi*2*Es/28)
  316.   Geiy(K)=190-50*Sin(Pi*2/496*K*31/33-Pi/33+Pi*2*Is/33)
  317. Next K
  318. '
  319. For K=8 To 496 Step 8
  320.   Defline 1,2,3,3
  321.   Line Korx(K-8),Kory(K-8),Korx(K),Kory(K)
  322.   Defline 3,2,3,3
  323.   Line Korx(K-8),Seey(K-8),Korx(K),Seey(K)
  324.   Defline 6,2,3,3
  325.   Line Korx(K-8),Geiy(K-8),Korx(K),Geiy(K)
  326. Next K
  327. Defline 1,2,0,0
  328. '
  329. A$=Chr$(Inp(2))
  330. If Asc(A$)=13 Then
  331.   Goto Weiter
  332. Endif
  333. If Asc(A$)=32 Then
  334.   Goto Eingabe
  335. Endif
  336. If Asc(A$)=42 Then
  337.   Goto Schluss
  338. Endif
  339. '
  340. Procedure Inputform
  341.   Local Key
  342.   Local I
  343.   Deftext ,1,0,13
  344.   Key$=""
  345.   Modus$(1)="1234567890"
  346.   Modus$(2)=Modus$(1)+"."
  347.   Modus$(3)="abcdefghijklmnopqrstuvwxyzßüöä ABCDEFGHIJKLMNOPQRSTUVWXYÜÖÄ"
  348.   Modus$(4)=Modus$(2)+Modus$(3)
  349.   Modus$(5)=Modus$(4)+"!§$%&/()=?`'^#*+@\]}[{,.-;:_~|"+Chr$(34)
  350.   Modus$(6)="jJyYnN"
  351.   If Modus<>0
  352.     Modus$=Modus$(Modus)
  353.   Endif
  354.   Repeat
  355.     Text X,Y,Upper$(Key$)+Chr$(4)+" "
  356.     Repeat
  357.       Key=Asc(Inkey$)
  358.     Until Key
  359.     If Key=8 Or Key=127 Or (Modus=2 And Key=42)
  360.       If Len(Key$)=0
  361.         Out 2,7
  362.       Else
  363.         Key$=Left$(Key$,Len(Key$)-1)
  364.       Endif
  365.     Else
  366.       If Instr(0,Modus$,Chr$(Key))=0 Or Len(Key$)>=Laenge
  367.         Out 2,7
  368.       Else
  369.         Key$=Key$+Chr$(Key)
  370.       Endif
  371.     Endif
  372.   Until Key=13
  373.   Text X,Y,Upper$(Key$)+" "
  374.   Deftext 1,0,0,13
  375. Return
  376. '
  377. Weiter:
  378. Bismon=Bismon+1
  379. If Bismon=13 Then
  380.   Bismon=1
  381.   Bisjah=Bisjah+1
  382. Endif
  383. Goto Nochmal
  384. '
  385. Fehler1:
  386. Deftext ,16,0,16
  387. Text 200,380,"Falsches Datum"
  388. Out 2,7
  389. Pause 10
  390. Out 2,7
  391. Pause 100
  392. Text 200,380,"              "
  393. Deftext ,0,0,13
  394. Text 420,138,"        "
  395. Goto Eindat1
  396. '
  397. Fehler2:
  398. Deftext ,16,0,16
  399. Text 200,380,"Falsches Datum"
  400. Out 2,7
  401. Pause 10
  402. Out 2,7
  403. Pause 100
  404. Text 200,380,"              "
  405. Deftext ,0,0,13
  406. Text 420,200,"      "
  407. Goto Eindat2
  408. '
  409. Fehler3:
  410. Deftext ,16,0,16
  411. Text 150,380,"Das geht nicht (Jahr=Geb.-Jahr)"
  412. Out 2,7
  413. Pause 10
  414. Out 2,7
  415. Pause 100
  416. Text 150,380,"                               "
  417. Deftext ,0,0,13
  418. Text 420,200,"      "
  419. Goto Eindat2
  420. '
  421. Schluss:
  422. Print Sauber$
  423. Graphmode 2
  424. Deftext ,4,,32
  425. Text 250,200,"Tschuess !!"
  426. Deffill 1,2,2
  427. Box 180,100,500,300
  428. Pbox 181,101,499,299
  429. Pause 200
  430. New
  431. End
  432.